functor
import
   Application System Pickle
   QTk     at 'x-oz://system/wp/QTk.ozf'
   Images  at 'Images.ozf'
   Field   at 'Field.ozf'
   Game    at 'Game.ozf'
   BinCons at 'BinCons.ozf'
   SetCons at 'SetCons.ozf'

define
   % extract the image from Images.ozf
   ImageLib = {QTk.buildImageLibrary Images.buildLibrary}
   Img = {ImageLib get(name:mozartPowered image:$)}

   % the window's description, with some widget's handle
   Desc = td(title:"The Oz Minesweeper"
	     lr(glue: nswe
		tbbutton(text: "New"   action: NewRandom  glue:nw)
		tbbutton(text: "Load"  action: LoadFile  glue:nw)
		tbbutton(text: "Save"  handle: SaveButton  glue:nw)
		tbbutton(text: "Quit"  action: toplevel#close  glue:ne)
	       )
	     lrline(glue:we)
	     lr(glue: nswe
		td(glue: nswe
		   label(text: "Rows"  glue:nw)
		   numberentry(handle: RowsEntry  glue:n
			       init: 10  max: 100  width: 5)
		   label(text: "Columns"  glue:nw)
		   numberentry(handle: ColsEntry  glue:n
			       init: 10  max: 100  width: 5)
		   label(text: "Mines"  glue:nw)
		   numberentry(handle: MinesEntry  glue:n
			       init: 20  max: 10000  width: 5)
		   label(image: Img  background: white  glue:s)
		  )
		tdline(glue:ns)
		td(glue: nswe
		   label(handle: StatusLabel  glue:we)
		   placeholder(handle: Grid  glue:nswe)
		  )
		tdline(glue:ns)
		td(glue: nswe
		   checkbutton(text: "Autoplay"  handle: AutoCheck
			       glue:nw  init:true)
		   checkbutton(text: "Zero propagation"  handle: ZeroCheck
			       glue:nw  init:true)
		   checkbutton(text: "Binary Constraints"  handle: BinConsCheck
			       glue:nw  init:true)
		   checkbutton(text: "Set Constraints"  handle: SetConsCheck
			       glue:nw)
		   lrline(glue:we)
		   radiobutton(text: "Binary search"  handle: BinSearchRadio
			       glue:sw  group: engine)
		   radiobutton(text: "Set search"
			       glue:sw  group: engine  init: true)
		   button(text: "Search"  handle: SearchButton  glue:we)
		   label(handle: FoundLabel)
		   label(handle: TotalLabel  glue:n)
		  )
	       )
	    )
   SaveButton RowsEntry ColsEntry MinesEntry StatusLabel Grid
   AutoCheck ZeroCheck BinConsCheck SetConsCheck
   SearchButton BinSearchRadio FoundLabel TotalLabel

   Window = {QTk.build Desc}

   SquareSize = 30

   % Shows messages about the global state of a game
   proc {ShowStatus S}
      {StatusLabel
       case S
       of still(N) then set(bg: white  text: "Still "#N#" squares to uncover")
       [] won      then set(bg: green  text: "You WON!")
       [] lost     then set(bg: red    text: "You LOSE!")
       end}
   end

   % shows a modal message window
   proc {ShowMessage Title Text}
      W = {QTk.build td(title: Title
			label(text: Text)
			button(text: "Close"  action: toplevel#close))}
   in
      {W show(wait:true modal:true)}
   end

   % creates a random new game
   proc {NewRandom}
      NR = {RowsEntry get($)}
      NC = {ColsEntry get($)}
      NM = {MinesEntry get($)}
   in
      {PlayGame {Field.random NR#NC NM} NR#NC nil}
   end

   % loads a game from a file
   Filetypes = q(q("Minesweeper files" q(Fileextension)) q("All files" q("*")))
   Fileextension = ".mine"
   proc {LoadFile}
      File = {QTk.dialogbox load(title: "Load game file..."
				 filetypes: Filetypes
				 defaultextension: Fileextension  $)}
   in
      if File \= nil then
	 try
	    game(B NR#NC Is) = {Pickle.load File}
	    NM = {Record.foldL B Number.'+' 0}
	 in
	    {RowsEntry set(NR)}
	    {ColsEntry set(NC)}
	    {MinesEntry set(NM)}
	    thread {PlayGame B NR#NC Is} end
	 catch _ then
	    {ShowMessage "Error" "Error while opening\n"#File}
	 end
      end
   end

   % set the grid to the game given by the binary field B, and plays
   % the squares given in PlayedIs
   proc {PlayGame B NR#NC PlayedIs}
      {StatusLabel set(bg: white  text: "Garbage collecting...")}
      {System.gcDo}

      % the symbolic field
      F
      Play = {Game.new NR#NC B F}
      NM   = {Record.foldL B Number.'+' 0}
      ToRC = {Field.coord NR#NC}.toRC

      % the save button
      {SaveButton set(action: SaveFile)}
      proc {SaveFile}
	 File = {QTk.dialogbox save(title: "Save game as..."
				    filetypes: Filetypes
				    defaultextension: Fileextension  $)}
      in
	 if File \= nil then
	    try
	       Is = {Filter {List.number 1 NR*NC 1}
		     fun {$ I} {IsDet F.I} andthen {IsDet F.I.1} end}
	    in
	       {Pickle.save game(B NR#NC Is) File}
	    catch _ then
	       {ShowMessage "Error" "Error while saving\n"#File}
	    end
	 end
      end

      % the status stream
      Status = {Game.status F NM}
      thread
	 {List.forAllTail Status
	  proc {$ X|Xr}
	     if {IsFree Xr} orelse Xr==nil then
		{ShowStatus X}  if X==lost then {Terminate} end
	     end
	  end}
      end
      proc {Terminate}
	 % stop the inference agents
	 {Auto enable(false)}
	 {Zero enable(false)}
	 {BinProp enable(false)}
	 {SetProp enable(false)}
	 for I in 1..NR*NC do {Play I} end
      end

      % put a new canvas in the placeholder
      GridCanvas = {Grid set(canvas(handle: $  bg: white
				    width: NC*SquareSize
				    height: NR*SquareSize))}

      % create the squares
      Marked = {NewArray 1 NR*NC false}
      Square = {Record.mapInd F
		fun {$ I X}
		   TagR = {GridCanvas newTag($)}   % tag for rectangle
		   TagT = {GridCanvas newTag($)}   % tag for text

		   R#C = {ToRC I}
		   X0 = (C-1) * SquareSize + 2
		   Y0 = (R-1) * SquareSize + 2
		   X1 = C * SquareSize
		   Y1 = R * SquareSize
		   XC = C * SquareSize - SquareSize div 2 + 1
		   YC = R * SquareSize - SquareSize div 2 + 1

		   proc {DoPlay}
		      if {IsFree X} orelse {Label X}\=mine then {Play I} end
		   end
		   proc {DoMark}
		      if {IsFree X} then B0 B1 in
			 B0 = Marked.I := B1
			 B1 = {Not B0}
			 {Square.I if B1 then "?" else "" end black gray}
		      end
		   end
		in
		   {GridCanvas create(rectangle X0 Y0 X1 Y1
				      fill: gray  outline: nil  tags: TagR)}
		   {GridCanvas create(text XC YC  text: ""
				      fill: black  tags: TagT)}
		   {TagR bind(event: "<1>"  action: DoPlay)}
		   {TagR bind(event: "<3>"  action: DoMark)}
		   {TagT bind(event: "<1>"  action: DoPlay)}
		   {TagT bind(event: "<3>"  action: DoMark)}
		   proc {$ Text TextColor SquareColor}
		      {TagR set(fill: SquareColor)}
		      {TagT set(text: Text  fill: TextColor)}
		   end
		end}

      % automatically update the interface
      for I in 1..NR*NC do
	 thread
	    case F.I of safe(K) then
	       {Delay 100}     % allows autoplay
	       if {IsFree K} then {Square.I "-" black gray} {Wait K} end
	       {Square.I K blue lightgray}
	    [] mine(K) then
	       {Square.I "X" black if {IsDet K} then red else lightgray end}
	    end
	 end
      end

      % the autoplayer
      Auto = {New Game.autoplay init(F Play)}
      proc {AutoAction} {Auto enable({AutoCheck get($)})} end
      {AutoAction} {AutoCheck set(action:AutoAction)}

      % the zero propagator
      Zero = {New Game.zeroProp init(F nrows:NR ncols:NC)}
      proc {ZeroAction} {Zero enable({ZeroCheck get($)})} end
      {ZeroAction} {ZeroCheck set(action:ZeroAction)}

      % the stream of binary constraints
      Cs = {BinCons.constraints F NR#NC NM}

      % the binary constraint propagator
      BinProp = {New BinCons.propagator init(F Cs)}
      proc {BinConsAction} {BinProp enable({BinConsCheck get($)})} end
      {BinConsAction} {BinConsCheck set(action:BinConsAction)}

      % the set constraint propagator
      SetProp = {New SetCons.propagator init(F Cs)}
      proc {SetConsAction} {SetProp enable({SetConsCheck get($)})} end
      {SetConsAction} {SetConsCheck set(action:SetConsAction)}

      % the binary and set search objects
      BinSolver = {New BinCons.solver init(Cs)}
      SetSolver = {New SetCons.solver init(Cs)}

      % the search action
      {SearchButton set(action: SearchAction)}
      proc {SearchAction}
	 Solver = if {BinSearchRadio get($)} then BinSolver else SetSolver end
	 SolverThread
	 Common Mean Found Total News
      in
	 {FoundLabel set(text: "")}
	 {TotalLabel set(text: "\n")}
	 {SearchButton set(text: "Stop"
			   action: proc {$}
				      try {Thread.terminate SolverThread}
				      catch _ then skip end
				   end)}

	 thread
	    try
	       SolverThread = {Thread.this}
	       {Solver search(common:Common mean:Mean found:Found total:Total)}

	       {SearchButton set(text: "Search"  action: SearchAction)}
	       {FoundLabel set(text: Found#" representatives")}
	       {TotalLabel set(text: "for "#{IntToFloat Total}#"\nsolutions")}

	       % tell common parts of solutions to F
	       News = for I in 1..NR*NC  sum:Inc do
			 if {IsDet Common.I} then
			    if {IsFree F.I} then {Inc 1} end
			    F.I = {Field.symbolic Common.I}
			 end
		      end

	       % show probabilities if nothing new appeared
	       if News == 0 then
		  Ps   = {Filter {Record.toList Mean} fun {$ X} X>0. end}
		  MinP = {FoldL Ps Min 1.}
	       in
		  {Record.forAllInd Mean
		   proc {$ I X}
		      if {IsFree F.I} andthen X > 0. andthen X < 1. then
			 {Square.I {Float.round X*100.}/100.
			  if X == MinP then green else white end
			  gray}
		      end
		   end}
		  {PrepareRefresh}
	       end

	    catch _ then   % the user hit the "Stop" button
	       {SearchButton set(text: "Search"  action: SearchAction)}
	       {Refresh}
	    end
	 end
      end

      % refresh the board
      proc {PrepareRefresh}
	 thread Xs = {Filter {Record.toList F} IsFree} in
	    if Xs \= nil then
	       {Record.waitOr {List.toTuple foo Xs} _} {Refresh}
	    end
	 end
      end
      proc {Refresh}
	 for I in 1..NR*NC do
	    if {IsFree F.I} then
	       {Square.I if Marked.I then "?" else "" end black gray}
	    end
	 end
      end
   in
      {FoundLabel set(text: "")}
      {TotalLabel set(text: "\n")}
      {ForAll PlayedIs Play}
   end

   % start the application
   {NewRandom}
   {Window show(wait:true)}
   {Application.exit 0}
end
